!-------------------------------------------------------------LICENSE--------------------------------------------------------------!
!                                                                                                                                  !
!The MAP code is written in Fortran language for magnetohydrodynamics (MHD) calculation with the adaptive mesh refinement (AMR)    !
!and Message Passing Interface (MPI) parallelization.                                                                              !
!                                                                                                                                  !
!Copyright (C) 2012                                                                                                                !
!Ronglin Jiang                                                                                                                     !
!rljiang@ssc.net.cn                                                                                                                !
!585 Guoshoujing Road. Pudong, Shanghai, P.R.C. 201203                                                                             !
!                                                                                                                                  !
!This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License         !
!as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.             !
!                                                                                                                                  !
!This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of    !
!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.                        !
!                                                                                                                                  !
!You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software     !
!Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.                                                   !
!                                                                                                                                  !
!-------------------------------------------------------------LICENSE--------------------------------------------------------------!

!==================================================================================================================================|
subroutine amr (base)
!==================================================================================================================================|

   use parameters
   use block_define
   use interface_block_reflux
   use interface_block_exchange
   use interface_block_shareblock
   use interface_block_update
   use interface_framework_sync
   use interface_integrate
!   use interface_integrate_sub
   use interface_load_balance
   use interface_memory_usage
   use interface_neigh_exchange
   use interface_neigh_reflux
   use interface_neigh_shareblock
   use interface_neigh_statistics
   use interface_regrid

   implicit none

   type(block), pointer, intent(in) :: base

   integer(4) :: i_level
   real(8) :: dt_global, et_global
   type(block), pointer :: current

!  call check_info ('regrid')
!----------------------------------------------------------------------------------------------------------------------------------|
!  regrid start
!----------------------------------------------------------------------------------------------------------------------------------|
   t_s = mpi_wtime ()

   if (t .gt. t_regrid .or. ns .le. 10) then
      if (ns .eq. 1 .or. fixed_mesh_flag .eq. 0) then

         max_level = 1

         do i_level = 1, n_levels - 1
            i_gene = 0
            gene = 0
            current => base%next
            do while (current%lv .ne. 0)
               if (current%lv .eq. i_level) call regrid(current)
               current => current%next
            enddo
            call framework_sync(base)
            call load_balance(base)
         enddo

         call neigh_statistics(base)

         len_regrid = 2 * ng * min(base%dx, base%dy, base%dz) * 2 ** (- dble(n_levels - 1))
         t_regrid = base%t + len_regrid / max_speed
         t_loop_pre = t_loop_pre * 100.0d0

!         call memory_usage(base)
      endif
   endif

   min_dt = base%dt * dble (ratio) ** (1 - max_level)
   call mpi_allreduce (min_dt, dt_global, 1, mpi_real8, mpi_min, mpi_comm_world, error)
   min_dt = dt_global

   min_dt_hc = base%dt_hc * dble (ratio) ** ((1 - max_level) * 2)
   call mpi_allreduce (min_dt_hc, dt_global, 1, mpi_real8, mpi_min, mpi_comm_world, error)
   min_dt_hc = dt_global

   if (isnan (min_dt)) then
      write (*, *)
      write (*, '(a)') ' Error: the dt is NaN.'
      write (*, '(a)') ' The program will be terminated.'
      write (*, *)
      call mpi_abort (mpi_comm_world, 1, error)
   endif

   t_e = mpi_wtime ()
   time_regrid_one = time_regrid_one + t_e - t_s

!----------------------------------------------------------------------------------------------------------------------------------|

!!----------------------------------------------------------------------------------------------------------------------------------|
!!  subcycle for heat conduction
!!----------------------------------------------------------------------------------------------------------------------------------|
!   if (min_dt_hc .lt. min_dt .and. thermal_amp .ge. eps) then

!      ns_hc = 1
!      do while (t_hc .lt. t + min_dt)
!!----------------------------------------------------------------------------------------------------------------------------------|
!!        integration for subcycle
!!----------------------------------------------------------------------------------------------------------------------------------|
!         t_s = mpi_wtime ()

!         if (t_hc + min_dt_hc .gt. t + min_dt) min_dt_hc = t + min_dt - t_hc

!         n_blocks_update_send = 0
!         do i_level = max_level, 1, -1
!            current => base%next
!            do while (current%lv .ne. 0)
!               if (current%lv .eq. i_level) call integrate_sub (current)
!               current => current%next
!            enddo
!         enddo

!         call block_update (base, 1, en_flag = .true.)

!         t_hc = t_hc + min_dt_hc

!         t_e = mpi_wtime ()
!         time_integrate_one = time_integrate_one + t_e - t_s

!!----------------------------------------------------------------------------------------------------------------------------------|
!!        boundary condition for subcycle
!!----------------------------------------------------------------------------------------------------------------------------------|
!         t_s = mpi_wtime ()

!         call neigh_exchange (base,                                                                                                &
!            neighs_exchange_send_x_hc, neighs_exchange_send_y_hc, neighs_exchange_recv_x_hc, neighs_exchange_recv_y_hc,            &
!            'x', 1, en_flag = .true.)

!         current => base%next
!         do while (current%lv .ne. 0)
!            call block_exchange (current, 'x', en_flag = .true.)
!            current => current%next
!         enddo

!         call neigh_exchange (base,                                                                                                &
!            neighs_exchange_send_x_hc, neighs_exchange_send_y_hc, neighs_exchange_recv_x_hc, neighs_exchange_recv_y_hc,            &
!            'y', 1, en_flag = .true.)

!         current => base%next
!         do while (current%lv .ne. 0)
!            call block_exchange (current, 'y', en_flag = .true.)
!            current => current%next
!         enddo

!         call neigh_shareblock (base,                                                                                              &
!            neighs_shareblock_send_x_hc, neighs_shareblock_send_y_hc, neighs_shareblock_recv_x_hc, neighs_shareblock_recv_y_hc,    &
!            1, en_flag = .true.)

!         current => base%next
!         do while (current%lv .ne. 0)
!            call block_shareblock (current, en_flag = .true.)
!            current => current%next
!         enddo

!         call neigh_exchange (base,                                                                                                &
!            neighs_exchange_send_x_hc, neighs_exchange_send_y_hc, neighs_exchange_recv_x_hc, neighs_exchange_recv_y_hc,            &
!            'y', 1, en_flag = .true., fix_flag = .true.)

!         current => base%next
!         do while (current%lv .ne. 0)
!            call block_exchange (current, 'y', en_flag = .true., fix_flag = .true.)
!            current => current%next
!         enddo

!         t_e = mpi_wtime ()
!         time_boundary_one = time_boundary_one + t_e - t_s
!         ns_hc = ns_hc + 1

!      enddo
!   endif

!----------------------------------------------------------------------------------------------------------------------------------|
!  integration
!----------------------------------------------------------------------------------------------------------------------------------|
   t_s = mpi_wtime ()
   n_blocks_update_send = 0
   do i_level = max_level, 1, -1
      current => base%next
      do while (current%lv .ne. 0)
         if (current%lv .eq. i_level) call integrate (current)
         current => current%next
      enddo
   enddo

   call mpi_allreduce (max_et, et_global, 1, mpi_real8, mpi_max, mpi_comm_world, error)
   max_et = et_global

   call block_update (base, 9, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,           &
      by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)

   t_e = mpi_wtime ()
   time_integrate_one = time_integrate_one + t_e - t_s

!----------------------------------------------------------------------------------------------------------------------------------|
!   call check_info ('boundary')

!----------------------------------------------------------------------------------------------------------------------------------|
!  boundary condition
!----------------------------------------------------------------------------------------------------------------------------------|
   t_s = mpi_wtime ()

!----------------------------------------------------------------------------------------------------------------------------------|
!  reflux
!----------------------------------------------------------------------------------------------------------------------------------|
   call neigh_reflux (base)

   current => base%next
   do while (current%lv .ne. 0)
      call block_reflux (current)
      current => current%next
   enddo

!----------------------------------------------------------------------------------------------------------------------------------|
!  exchange
!----------------------------------------------------------------------------------------------------------------------------------|
   call neigh_exchange (base, neighs_exchange_send_x, neighs_exchange_send_y, neighs_exchange_send_z,                              &
                              neighs_exchange_recv_x, neighs_exchange_recv_y, neighs_exchange_recv_z,                              &
      'x', 9, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,                            &
              by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)

   current => base%next
   do while (current%lv .ne. 0)
      call block_exchange (current, 'x', ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true., &
         by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)
      current => current%next
   enddo

   call neigh_exchange (base, neighs_exchange_send_x, neighs_exchange_send_y, neighs_exchange_send_z,                              &
                              neighs_exchange_recv_x, neighs_exchange_recv_y, neighs_exchange_recv_z,                              &
      'y', 9, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,                            &
              by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)

   current => base%next
   do while (current%lv .ne. 0)
      call block_exchange (current, 'y', ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true., &
         by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)
      current => current%next
   enddo

   call neigh_exchange (base, neighs_exchange_send_x, neighs_exchange_send_y, neighs_exchange_send_z,                              &
                              neighs_exchange_recv_x, neighs_exchange_recv_y, neighs_exchange_recv_z,                              &
      'z', 9, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,                            &
              by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)

   current => base%next
   do while (current%lv .ne. 0)
      call block_exchange (current, 'z', ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true., &
         by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)
      current => current%next
   enddo

!----------------------------------------------------------------------------------------------------------------------------------|
!  shareblock
!----------------------------------------------------------------------------------------------------------------------------------|
   call neigh_shareblock (base, neighs_shareblock_send_x, neighs_shareblock_send_y, neighs_shareblock_send_z,                      &
                                neighs_shareblock_recv_x, neighs_shareblock_recv_y, neighs_shareblock_recv_z,                      &
      9, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,                                 &
      by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)

   current => base%next
   do while (current%lv .ne. 0)
      call block_shareblock (current, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,    &
      by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)
      current => current%next
   enddo

!----------------------------------------------------------------------------------------------------------------------------------|
!  exchange for fixing
!----------------------------------------------------------------------------------------------------------------------------------|
!   call neigh_exchange (base, neighs_exchange_send_x, neighs_exchange_send_y, neighs_exchange_send_z,                              &
!                              neighs_exchange_recv_x, neighs_exchange_recv_y, neighs_exchange_recv_z,                              &
!      'x', 9, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,                            &
!              by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)

!   current => base%next
!   do while (current%lv .ne. 0)
!      call block_exchange (current, 'x', ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true., &
!         by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)
!      current => current%next
!   enddo

   call neigh_exchange (base, neighs_exchange_send_x, neighs_exchange_send_y, neighs_exchange_send_z,                              &
                              neighs_exchange_recv_x, neighs_exchange_recv_y, neighs_exchange_recv_z,                              &
      'y', 9, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,                            &
              by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)

   current => base%next
   do while (current%lv .ne. 0)
      call block_exchange (current, 'y', ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true., &
         by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)
      current => current%next
   enddo

   call neigh_exchange (base, neighs_exchange_send_x, neighs_exchange_send_y, neighs_exchange_send_z,                              &
                              neighs_exchange_recv_x, neighs_exchange_recv_y, neighs_exchange_recv_z,                              &
      'z', 9, ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true.,                            &
              by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)

   current => base%next
   do while (current%lv .ne. 0)
      call block_exchange (current, 'z', ro_flag = .true., mx_flag = .true., my_flag = .true., mz_flag = .true., bx_flag = .true., &
         by_flag = .true., bz_flag = .true., en_flag = .true., po_flag = .true.)
      current => current%next
   enddo

   t_e = mpi_wtime ()
   time_boundary_one = time_boundary_one + t_e - t_s

!   current => base%next
!   do while (current%lv .ne. 0)
!!      if (all(reshape(current%id, (/ 6 /)) .eq. (/ 1, 1, 1, 0, 0, 0 /))) then
!loop: do k = 1, nz_block
!      do j = 1, ny_block
!      do i = 1, nx_block
!!         if (isnan (current%en(i, j, k)) .or. current%en(i, j, k) .le. 10) then
!         if (isnan (current%ro(i, j, k)) .or. current%ro(i, j, k) .le. eps) then
!            print*, current%id, i,j,k,cpu_id
!!            print*, current%parent%en
!!            print*, current%neigh(-1,0)%pblock%id, current%neigh(-1,0)%pblock%cpu_id
!!            print*, current%neigh(1,0)%pblock%id, current%neigh(1,0)%pblock%cpu_id
!!            print*, current%neigh(0,-1)%pblock%id, current%neigh(0,-1)%pblock%cpu_id
!!            print*, current%neigh(0,1)%pblock%id, current%neigh(0,1)%pblock%cpu_id
!!            print*, current%neigh(0,1)%pblock%en(:,21:24)
!!            exit loop
!            pause
!         endif
!      enddo
!      enddo
!      enddo loop
!!      endif
!      current => current%next
!   enddo

!   current => base%next
!   do while (current%lv .ne. 0)
!!      if (cpu_id .eq. 0) then
!!         if (all (reshape(current%id, (/6/)) .eq. (/5,2,1,1,2,2/)) .and. ns .eq. 219) then
!!         do j = 5, ny_block - 4
!!         do i = 5, nx_block - 4
!         do k = 1, nz_block
!         do j = 1, ny_block
!         do i = 1, nx_block
!            if (isnan(current%en(i, j, k)) .or. current%en(i, j, k) .le. 0.0d0) then
!!print*, neighs_exchange_info_send_y(1:6,1:8,2)
!               print*, n_neighs_exchange_sendrecv_fix_y
!               print*, ns, i, j, k, current%en(i, j, k) !current%neigh(0,1)%pblock%ro(:,1:4) !, current%neigh(1,0)%pblock%ro(1:4,1:4)
!   pause
!            endif
!         enddo
!         enddo
!         enddo
!!         endif
!!      endif
!      current => current%next
!   enddo

!if (ns .eq. 4) then
!print*, n_neighs_exchange_sendrecv_fix_y
!pause
!endif
!   current => base%next
!   current => current%next
!   if (cpu_id .eq. 1) then
!      print*, current%ro(1:4,:)
!      pause
!   endif

!   current => base%next
!   do while (current%lv .ne. 0)
!      loop: do j = 1, ny_block
!      do i = 1, nx_block
!         if (isnan (current%en(i, j)) .and. cpu_id .eq. 0) then
!            print*, current%id, ns, n_blocks_all
!            print*, current%en(2,21)
!!            print*, current%parent%en
!!            print*, current%neigh(-1,0)%pblock%id, current%neigh(-1,0)%pblock%cpu_id
!!            print*, current%neigh(1,0)%pblock%id, current%neigh(1,0)%pblock%cpu_id
!!            print*, current%neigh(0,-1)%pblock%id, current%neigh(0,-1)%pblock%cpu_id
!!            print*, current%neigh(0,1)%pblock%id, current%neigh(0,1)%pblock%cpu_id
!!            print*, current%neigh(0,1)%pblock%en(:,21:24)
!!            exit loop
!            pause
!         endif
!      enddo
!      enddo loop
!      current => current%next
!   enddo

!pause
!   current => base%next
!   do while (current%lv .ne. 0)
!      do j = 1, ny_block
!      do i = 1, nx_block
!         if (isnan (current%en(i, j))) then
!!         if (all (reshape (current%id, (/6/)) .eq. (/3,3,1,2,2,2/)) .and. ns_hc .eq. 12 .and. ns .eq. 39) then
!!            print*, ns_hc, ns, cpu_id, min_dt_hc, min_dt, i, j
!!            print*, current%id
!!            print*, current%parent%en(:,21:24)
!!            print*, ns, i, j, current%id
!            print*, current%neigh(-1,0)%pblock%id
!            print*, current%neigh(0,-1)%pblock%id
!            print*, current%neigh(-1,-1)%pblock%id
!            pause
!         endif
!      enddo
!      enddo
!      current => current%next
!   enddo

!   current => base%next
!   do while (current%lv .ne. 0)
!      if (all (reshape (current%id, (/6/)) .eq. (/2,1,2,1,2,1/))) then
!         do j = 1, 24
!         do i = 1, 24
!               print*, ns, ns_hc, i, j, cpu_id, current%id
!               pause
!            endif
!         enddo
!         enddo
!      endif
!      current => current%next
!   enddo

!   current => base%next
!   do while (current%lv .ne. 0)
!      if (cpu_id .eq. 2 .and. ns .eq. 2) then
!      if (all (reshape (current%id, (/2/)) .eq. (/3,9/))) then
!         print*, current%ro(12,1:8), max_speed
!pause
!      endif
!      endif
!      current => current%next
!   enddo

!   current => base%next
!   do while (current%lv .ne. 0)
!      if (cpu_id .eq. 4 .and. ns .eq. 2) then
!      if (all (reshape (current%id, (/2/)) .eq. (/6,9/))) then
!         print*, current%ro(13,1:8), max_speed
!pause
!      endif
!      endif
!      current => current%next
!   enddo

!----------------------------------------------------------------------------------------------------------------------------------|

   return
end subroutine amr
